perm filename CONMSS.F4[RST,LCS] blob
sn#189913 filedate 1975-11-30 generic text, type T, neo UTF8
00010 C CONVERTS .DAT TO .DMD LOAD WITH MSSIO.FAI[XX,LCS]
00100 IMPLICIT INTEGER(A-Q,S-Z)
00200 REAL DIS,PWDS,DISX,A,B,STFF,CENTR,POS ,UD
00400 COMMON/STF/RSTFAC(-3/4),RSTJ2/POSI/STFF(-3/4),X,Y
00500 COMMON/SCM/V(78),ISCR,LCNT,IR,LIST(200)
00550 C ORDER OF COMMON BLOCKS MUST STAY AS IS!
00600 COMMON/XRN/RN(2050)
00700 1 /PTR/PWDS(250),ITEM,L,I,IX
00770 DIMENSION KWDS(250)
00785 EQUIVALENCE (KWDS,PWDS)
00800 83 TYPE 1
00900 1 FORMAT(' TYPE NAME 1, (N) ',$)
01000 2 FORMAT(' TYPE FINAL NAME ',$)
01100 3 FORMAT(A5,I)
01200 4 FORMAT(1XA5)
01300 ACCEPT 3,NAME,T
01350 NAMZ=NAME
01375 10 IF(T.NE.0)GO TO 13
01400 IF(LOOKD(NAME))GO TO 284
01500 NAME=NAMZ+256
01600 IF(LOOKD(NAME).GE.0)GO TO 83
01700 NAMZ=NAME
01800 C FOUND NO MORE TO READ
01900 284 CALL IFILE(21,NAME)
02000 2202 READ(21),X,Y,
02100 1 (PWDS(K),K=1,X+1),(RN(K),K=1,Y-1),ISCR,(V(K),K=1,ISCR),
02200 1 LCNT,(LIST(K),K=1,LCNT),RSTFAC,STFF,RPOS
02300 X=X+2
02305 C WRITE EXTRA WORD
02310 DO 77 K=1,X
02320 77 KWDS(K)=PWDS(K)
02400 CC Y=Y-1
02600 IR=0
02650 C FLAG FOR NO DPY BUFFER
02700 19 CALL PUTFIL(NAME)
02800 CALL FASTOU(RSTFAC,128)
02900 CALL FASTOU(PWDS,X)
03000 CALL FASTOU(RN,Y)
03100 IF(LCNT.GT.1)CALL FASTOU(LIST,LCNT)
03300 CALL FINFIL
03350 TYPE 4,NAME
03400 20 NAME=NAME+2
03500 GO TO 10
03600 13 IF(LOOKF(NAME))GO TO 14
03700 NAME=NAMZ+256
03800 IF(LOOKF(NAME).GE.0)GO TO 83
03900 NAMZ=NAME
04000 C FOUND NO MORE TO READ
04100 14 CALL GETFIL(NAME)
05000 CALL FASTIN(RSTFAC,128)
05100 CALL FASTIN(PWDS,X)
05200 CALL FASTIN(RN,Y)
05400 IF(LCNT.GT.1)CALL FASTIN(LIST,LCNT)
05450 Q=0
05500 DO 15 K=1,X-1
05600 J=KWDS(K)
05700 IF(RN(J+1).NE.16)GO TO 15
05800 C TO CONVERT TEXT TO NEW FORMAT
05850 A=0
05900 DO 16 N=J+6,J+8
06000 R=RN(N)
06100 M=R
06150 IF(M.GE.1000000)GO TO 20
06175 C JUMP OUT IF ALREADY CONVERTED
06200 16 IF(M.NE.R)A=-1
06300 IF(A.EQ.0)GO TO 15
06400 17 DO 18 N=J+6,J+8
06500 18 RN(N)=RN(N)*100.0
06550 Q=-1
06600 15 CONTINUE
06700 IF(Q)GO TO 19
06750 GO TO 20
06800 END